home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Visual Basic 4 Database How-To
/
Visual Basic 4 Database - How-to (The Waite Group)(1995).iso
/
isam2.fr_
/
isam2.fr
Wrap
Text File
|
1995-07-05
|
24KB
|
771 lines
VERSION 4.00
Begin VB.Form frmCustomers
BackColor = &H00C0C0C0&
Caption = "Customers"
ClientHeight = 3870
ClientLeft = 2100
ClientTop = 3060
ClientWidth = 8205
BeginProperty Font
name = "MS Sans Serif"
charset = 0
weight = 700
size = 8.25
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
Height = 4275
Left = 2040
LinkTopic = "Form1"
ScaleHeight = 3870
ScaleWidth = 8205
Top = 2715
Width = 8325
Begin VB.CommandButton cmdMove
Caption = ">>"
BeginProperty Font
name = "MS Sans Serif"
charset = 0
weight = 700
size = 9.75
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
Height = 315
Index = 3
Left = 2100
TabIndex = 26
Top = 3240
Width = 495
End
Begin VB.CommandButton cmdMove
Caption = ">"
BeginProperty Font
name = "MS Sans Serif"
charset = 0
weight = 700
size = 9.75
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
Height = 315
Index = 2
Left = 1620
TabIndex = 25
Top = 3240
Width = 495
End
Begin VB.CommandButton cmdMove
Caption = "<"
BeginProperty Font
name = "MS Sans Serif"
charset = 0
weight = 700
size = 9.75
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
Height = 315
Index = 1
Left = 1140
TabIndex = 24
Top = 3240
Width = 495
End
Begin VB.CommandButton cmdMove
Caption = "<<"
BeginProperty Font
name = "MS Sans Serif"
charset = 0
weight = 700
size = 9.75
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
Height = 315
Index = 0
Left = 660
TabIndex = 23
Top = 3240
Width = 495
End
Begin VB.CommandButton cmdDelete
Caption = "&Delete"
Height = 315
Left = 5160
TabIndex = 22
Top = 3240
Width = 1155
End
Begin VB.CommandButton cmdClose
Caption = "Cl&ose"
Height = 315
Left = 6660
TabIndex = 21
Top = 3240
Width = 1155
End
Begin VB.TextBox txtData
Alignment = 2 'Center
DataField = "STATE"
DataSource = "Data1"
Height = 315
Index = 6
Left = 4800
MaxLength = 2
TabIndex = 13
Top = 2100
Width = 405
End
Begin VB.TextBox txtData
DataField = "ZIPCODE"
DataSource = "Data1"
Height = 315
Index = 7
Left = 6360
MaxLength = 10
TabIndex = 15
Top = 2100
Width = 1215
End
Begin VB.TextBox txtData
DataField = "PHONE"
DataSource = "Data1"
Height = 315
Index = 8
Left = 1380
MaxLength = 14
TabIndex = 17
Top = 2580
Width = 1875
End
Begin VB.TextBox txtData
DataField = "FAX"
DataSource = "Data1"
Height = 315
Index = 9
Left = 3900
MaxLength = 14
TabIndex = 19
Top = 2580
Width = 1875
End
Begin VB.CommandButton cmdAdd
Caption = "&Add"
Height = 315
Left = 3600
TabIndex = 20
Top = 3240
Width = 1215
End
Begin VB.TextBox txtData
DataField = "CITY"
DataSource = "Data1"
Height = 315
Index = 5
Left = 1380
MaxLength = 20
TabIndex = 11
Top = 2100
Width = 2595
End
Begin VB.TextBox txtData
DataField = "ADDRESS2"
DataSource = "Data1"
Height = 315
Index = 4
Left = 1380
MaxLength = 20
TabIndex = 9
Top = 1620
Width = 4215
End
Begin VB.TextBox txtData
DataField = "ADDRESS1"
DataSource = "Data1"
Height = 315
Index = 3
Left = 1380
MaxLength = 40
TabIndex = 7
Top = 1140
Width = 4215
End
Begin VB.TextBox txtData
DataField = "CUSTNUM"
DataSource = "Data1"
Height = 285
Index = 0
Left = 1965
MaxLength = 5
TabIndex = 1
Top = 210
Width = 750
End
Begin VB.TextBox txtData
DataField = "FIRSTNAME"
DataSource = "Data1"
Height = 315
Index = 2
Left = 5280
MaxLength = 20
TabIndex = 5
Top = 660
Width = 2595
End
Begin VB.TextBox txtData
DataField = "LASTNAME"
DataSource = "Data1"
Height = 315
Index = 1
Left = 1380
MaxLength = 20
TabIndex = 3
Top = 660
Width = 2595
End
Begin VB.Label lblFax
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "Fa&x:"
Height = 195
Left = 3420
TabIndex = 18
Top = 2640
Width = 375
End
Begin VB.Label lblPhone
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "&Phone:"
Height = 195
Left = 660
TabIndex = 16
Top = 2640
Width = 615
End
Begin VB.Label Label3
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "&Zip Code:"
Height = 195
Left = 5415
TabIndex = 14
Top = 2160
Width = 840
End
Begin VB.Label Label2
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "S&tate:"
Height = 195
Left = 4170
TabIndex = 12
Top = 2160
Width = 525
End
Begin VB.Label Label1
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "&City:"
Height = 195
Left = 885
TabIndex = 10
Top = 2160
Width = 390
End
Begin VB.Label lblAddress2
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "Addr&ess 2:"
Height = 195
Left = 360
TabIndex = 8
Top = 1680
Width = 915
End
Begin VB.Label lblAddress1
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "Addre&ss 1:"
Height = 195
Left = 360
TabIndex = 6
Top = 1200
Width = 915
End
Begin VB.Label lblCustomerNumber
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "Customer &Number:"
Height = 195
Left = 300
TabIndex = 0
Top = 240
Width = 1560
End
Begin VB.Label lblFirst
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "&First Name:"
Height = 195
Left = 4200
TabIndex = 4
Top = 720
Width = 975
End
Begin VB.Label lblLast
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Caption = "&Last Name:"
Height = 195
Left = 300
TabIndex = 2
Top = 720
Width = 975
End
End
Attribute VB_Name = "frmCustomers"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' DataChanged is used to keep track of whether a form needs to be saved.
' It is set at false by the first call to DisplayRecord. All text box Change
' events set it true. When a record is saved or a new record is displayed,
' it is reset back to false.
Private DataChanged As Boolean
' db is the database variable, declared at form level. It is Set to
' the correct directory in the Form Load event.
Private db As DATABASE
' rs is the customer recordset. It is Set to the CUSTOMER.DBF
' table in the Form_Load event.
Private rs As Recordset
' We use a control array for the text boxes. The following constants are
' used to make the array index numbers meaningful.
Private Const CUSTNUM = 0
Private Const LASTNAME = 1
Private Const FIRSTNAME = 2
Private Const ADDRESS1 = 3
Private Const ADDRESS2 = 4
Private Const CITY = 5
Private Const STATE = 6
Private Const ZIPCODE = 7
Private Const PHONE = 8
Private Const FAX = 9
Private Sub Form_Load()
Dim dbName As String
' Set the two data access object variables that were declared at
' module level.
' Get the database name and open the database.
dbName = DataPath() & "\CHAPTER.05" ' DataPath() is in READINI.BAS
Set db = DBEngine.Workspaces(0).OpenDatabase _
(dbName, False, False, "dBase IV")
Set rs = db.OpenRecordset("CUSTOMER", dbOpenTable)
End Sub
Private Sub Form_Activate()
' If there are no records in the table, then both beginning-of-file (BOF)
' and end-of-file (EOF) are True. If this is true, call EmptyRecordset,
' which gives the user a choice between adding a new blank record and
' terminating the program.
If rs.BOF And rs.EOF Then EmptyRecordset
' Display the first record in the table recordset.
DisplayRecord
End Sub
Private Sub cmdAdd_Click()
' The user clicked the Add button.
With rs
' Prepare to add a new blank record.
.AddNew
' Now actually add the record.
.UPDATE
' Move to the new record
.MoveLast
End With
' Display the new record for user entry.
DisplayRecord
End Sub
Private Sub cmdDelete_Click()
' Get confirmation that the user wants to delete the current record.
If MsgBox("Do you want to delete " & MakeName(CStr(txtData(LASTNAME)), _
CStr(txtData(FIRSTNAME))) & "?", vbQuestion + vbYesNo + vbDefaultButton2) _
= vbYes Then
' Delete the record
' To remove the record from the active set, the line "Deleted=On"
' must appear in the [dBase ISAM] section of VB.INI or the
' application's INI file. See How-To 4.1 for details.
' If the user deleted the only record in the database, call the
' EmptyRecordset procedure to give the user a chance to add a new
' blank record. If the user chooses not to add a new record,
' EmptyRecordset terminates the program.
rs.DELETE
' If the user deleted the only record in the database, call the
' EmptyRecordset procedure to give the user a chance to add a new
' blank record. If the user chooses not to add a new record,
' EmptyRecordset terminates the program.
If rs.BOF And rs.EOF Then
EmptyRecordset
Else
' After a delete, the recordset has no current record. So move
' to the next record in the recordset.
rs.MoveNext
' If the user deleted the record that was positioned
' at the end of the database, move to the previous record. Since
' we checked earlier for an empty database, we know there must
' a previous record.
If rs.EOF Then rs.MovePrevious
' Display the new current record.
DisplayRecord
End If
End If
End Sub
Private Sub cmdClose_Click()
Unload frmCustomers
End Sub
Private Sub cmdMove_Click(Index As Integer)
' The user clicked one of the navigation buttons - First, Prev, Next, or
' Last. Since these buttons are a control array, the specific button
' clicked is passed in the Index argument.
Dim performMove As Integer
Const MOVE_FIRST = 0
Const MOVE_PREVIOUS = 1
Const MOVE_NEXT = 2
Const MOVE_LAST = 3
' Set the performMove flag to its default value
performMove = True
' If the data have changed since the last time the record was saved, save
' the record. If the save is successful, performMove will remain True;
' otherwise, it will be set to False.
If DataChanged Then performMove = SaveRecord()
' If the data have not changed or the save operation was successful, then
' change to the specified record.
If performMove = True Then
Select Case Index
Case MOVE_NEXT
' Check to make sure the record pointer's not at EOF. Without
' this, an error would occur if the pointer was at EOF.
If Not rs.EOF Then
' Okay to move to the next record.
rs.MoveNext
' Now did the move put the pointer at EOF? If so, there's
' no current record, and several other routines assume
' there's always a current record. So if the pointer's at
' EOF, move it back to where it was.
If rs.EOF Then rs.MovePrevious
End If
Case MOVE_PREVIOUS
' Check to make sure the record pointer's not at BOF. Without
' this, an error would occur if the pointer was at BOF.
If Not rs.BOF Then
' Okay to move to the previous record.
rs.MovePrevious
' Now did the move put the pointer at BOF? If so, there's
' no current record, and several other routines assume
' there's always a current record. So if the pointer's at
' BOF, move it back to where it was.
If rs.BOF Then rs.MoveNext
End If
Case MOVE_LAST
' Move the record pointer to the last record in the file.
rs.MoveLast
Case MOVE_FIRST
' Move the record pointer to the first record in the file.
rs.MoveFirst
End Select
' Show the record the record pointer's currently pointing at.
DisplayRecord
End If
End Sub
Sub EmptyRecordset()
' Gives the user a chance to add a record to the data base. If the user
' elects not to add a record, the program terminates.
Dim msg1 As String, msg2 As String, msg3 As String
msg1 = "There are no customer records in the data base. "
msg2 = "Do you want to add a new blank record? "
msg3 = "(If you answer no, the program will terminate.)"
If MsgBox(msg1 & msg2 & msg3, vbQuestion + vbYesNo) = vbYes Then
cmdAdd_Click
Else
End
End If
End Sub
Private Function MakeName(LASTNAME As String, FIRSTNAME As String) As String
' Returns a name of the form First Last, compensating for the
' possibility that either first or last name may be a zero-length string.
Dim nm As String
nm = FIRSTNAME & IIf(FIRSTNAME <> "", " ", "") & LASTNAME
MakeName = IIf(nm = "", "the current record", nm)
End Function
Private Sub DisplayField(txt As TextBox, fieldName As String)
' If fieldName is not null, displays the contents of the field in the
' text box. If the field is null, displays an empty string.
txt = IIf(Not IsNull(rs(fieldName)), rs(fieldName), "")
End Sub
Private Sub DisplayRecord()
' displays the current record
DisplayField txtData(CUSTNUM), "CUSTNUM"
DisplayField txtData(LASTNAME), "LASTNAME"
DisplayField txtData(FIRSTNAME), "FIRSTNAME"
DisplayField txtData(ADDRESS1), "ADDRESS1"
DisplayField txtData(ADDRESS2), "ADDRESS2"
DisplayField txtData(CITY), "CITY"
DisplayField txtData(STATE), "STATE"
DisplayField txtData(ZIPCODE), "ZIPCODE"
DisplayField txtData(PHONE), "PHONE"
DisplayField txtData(FAX), "FAX"
txtData(CUSTNUM).SetFocus
' DataChanged is set to true by the Change event of every text box
' which fires in every DisplayField routine. Set it false now because
' the data have not changed since the last save.
DataChanged = False
End Sub
Private Function SaveRecord()
' This procedure saves the current record to he data base file. If it is
' successful, it returns True. If an error occurs, it returns False.
On Error GoTo SaveRecordError
With rs
' Move the record into the edit buffer.
.Edit
' Now set the data fields from the text boxes on the form.
!CUSTNUM = txtData(CUSTNUM)
!LASTNAME = txtData(LASTNAME)
!FIRSTNAME = txtData(FIRSTNAME)
!ADDRESS1 = txtData(ADDRESS1)
!ADDRESS2 = txtData(ADDRESS2)
!CITY = txtData(CITY)
!STATE = UCase$(txtData(STATE))
!ZIPCODE = txtData(ZIPCODE)
!PHONE = txtData(PHONE)
!FAX = txtData(FAX)
' Now update the data base. If you forget this step you'll accomplish
' nothing - and no error message to warn you! If an error occurs
' before this step is reached, the data will not be saved, since the
' error-handling routine exits from the function.
.UPDATE
End With
' Set the module-level variable DataChanged to false.
DataChanged = False
' Return True to indicated that the data were saved successfully.
SaveRecord = True
Exit Function
SaveRecordError:
' If an error code 13 (Type Mismatch) caused the error, the error must be
' in the Customer Number field which requires a numeric value (all the
' other text boxes are saved to text fields and they will take anything),
' so display a meaningful error message.
If Err = 13 Then
MsgBox "The Customer Number field must contain a numeric value.", _
vbExclamation
txtData(CUSTNUM).SetFocus
Else
' Not error 13, so just pass through Visual Basic's error message.
MsgBox Error(Err)
End If
' Return False to indicated that the data were not saved successfully.
SaveRecord = False
Exit Function
End Function
Private Sub txtData_Change(Index As Integer)
DataChanged = True
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' This event is evoked automatically before the program is unloaded.
' If the UnloadMode argument indicates that the cause of the unload
' request is from the Windows Task Manager's End Task command or from a
' command to exit from Windows, then the procedure calls ExitProgram().
' If the current record need not be saved or if the current record is
' saved without error, ExitProgram() simply Ends; otherwise, it returns
' False. The False is converted to a True, which is returned to the
' calling program by assigning it to the Cancel argument. Since setting
' Cancel to any non-zero value cancels the event, this prevents the
' program from being terminated.
' If the cause of the Unload query is the user choosing Close or closing
' through the Control menu, ExitProgram() is called from the Form_Unload
' or procedure, so there's no need to duplicate the call here.
Const TASKMANAGER = 2
Const EXITWINDOWS = 3
If UnloadMode = TASKMANAGER Or UnloadMode = EXITWINDOWS Then
Cancel = Not ExitProgram()
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
' Calls the ExitProgram routine, which saves the current record if it's
' been changed, then executes an End statement.
If ExitProgram() = False Then Cancel = True
End Sub
Private Sub mnuFileExit_Click()
' The user clicked Exit on the File menu or pressed Ctrl-Q.
' Calls the ExitProgram routine which saves the current record if it's
' been changed, then executes an End statement. If the save fails,
' ExitProgram does not execute the End, but instead returns a False.
' This procedure just ignores the return value and does nothing if
' the program cannot exit.
ExitProgram
End Sub
Private Function ExitProgram() As Boolean
' This routine is called from the mnuFileExit_Click event and from the
' Form_Unload event. This gives the application consistent behavior no
' matter how the user exits from the program. If the current record does
' not need saving or if it's saved successfully, the function Ends the
' program. If the current record is not saved successfully, the function
' returns a False.
If DataChanged Then
If SaveRecord() = True Then
End
Else
ExitProgram = False
End If
Else
End
End If
End Function
